home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / guile-ii.src / guile-ii / guile-src / slib / scheme48.init < prev    next >
Encoding:
Text File  |  1995-01-04  |  7.4 KB  |  240 lines
  1. ;;;"scheme48.init" Initialisation for SLIB for Scheme48    -*-scheme-*-
  2. ;;; Copyright (C) 1992, 1993, 1994, 1995 Aubrey Jaffer.
  3. ;
  4. ;Permission to copy this software, to redistribute it, and to use it
  5. ;for any purpose is granted, subject to the following restrictions and
  6. ;understandings.
  7. ;
  8. ;1.  Any copy made of this software must include this copyright notice
  9. ;in full.
  10. ;
  11. ;2.  I have made no warrantee or representation that the operation of
  12. ;this software will be error-free, and I am under no obligation to
  13. ;provide any services, by way of maintenance, update, or otherwise.
  14. ;
  15. ;3.  In conjunction with products arising from the use of this
  16. ;material, there shall be no use of my name in any advertising,
  17. ;promotional, or sales literature without prior written consent in
  18. ;each case.
  19.  
  20. ;;; If you know the magic incantation to make a "," command available
  21. ;;; as a scheme procedure, you can make a nifty slib function to do
  22. ;;; this (like `slib:dump' in "vscm.init").  But for now, type:
  23. ;;;    make slib48
  24.  
  25. ;;; (software-type) should be set to the generic operating system type.
  26. ;;; UNIX, VMS, MACOS, AMIGA and MS-DOS are supported.
  27.  
  28. (define (software-type) 'UNIX)
  29.  
  30. ;;; (scheme-implementation-type) should return the name of the scheme
  31. ;;; implementation loading this file.
  32.  
  33. (define (scheme-implementation-type) 'Scheme48)
  34.  
  35. ;;; (scheme-implementation-version) should return a string describing
  36. ;;; the version the scheme implementation loading this file.
  37.  
  38. (define (scheme-implementation-version) "0.36")
  39.  
  40. ;;; (implementation-vicinity) should be defined to be the pathname of
  41. ;;; the directory where any auxiliary files to your Scheme
  42. ;;; implementation reside.
  43. ; For scheme48, perhaps something like /usr/local/src/scheme48/misc/ ?
  44.  
  45. (define (implementation-vicinity)
  46.   (case (software-type)
  47.     ((UNIX)      "=scheme48/")    ; Translated
  48.     (else (slib:error "unrecognized software-type" software-type))))
  49.  
  50. ;;; (library-vicinity) should be defined to be the pathname of the
  51. ;;; directory where files of Scheme library functions reside.
  52.  
  53. (define (library-vicinity) "/usr/local/lib/slib/")
  54.  
  55. ;;; *FEATURES* should be set to a list of symbols describing features
  56. ;;; of this implementation.  See Template.scm for the list of feature
  57. ;;; names.
  58.  
  59. (define *features*
  60.       '(
  61.     source                ;can load scheme source files
  62.                     ;(slib:load-source "filename")
  63. ;    compiled            ;can load compiled files
  64.                     ;(slib:load-compiled "filename")
  65.     rev4-report            ;conforms to
  66.     ieee-p1178            ;conforms to
  67.     rev4-optional-procedures
  68.     multiarg/and-
  69.     multiarg-apply
  70.     rationalize
  71.     delay                ;has delay and force
  72.     with-file
  73.     char-ready?            ;has
  74.     values                ;proposed multiple values
  75.     eval                ;slib:eval is single argument eval.
  76.     dynamic-wind            ;proposed dynamic-wind
  77.     full-continuation        ;can return multiple times
  78.     macro                ;R4RS appendix's DEFINE-SYNTAX
  79.     ))
  80.  
  81. ;;; (OUTPUT-PORT-WIDTH <port>)
  82. (define (output-port-width . arg) 79)
  83.  
  84. ;;; (OUTPUT-PORT-HEIGHT <port>)
  85. (define (output-port-height . arg) 24)
  86.  
  87. ;;; (CURRENT-ERROR-PORT)
  88. (define current-error-port
  89.   (access-scheme-48 'error-output-port))
  90.  
  91. ;;; (TMPNAM) makes a temporary file name.
  92. (define tmpnam
  93.   (let ((cntr 100))
  94.     (lambda () (set! cntr (+ 1 cntr))
  95.         (let ((tmp (string-append "slib_" (number->string cntr))))
  96.           (if (file-exists? tmp) (tmpnam) tmp)))))
  97.  
  98. ;;; (FILE-EXISTS? <string>)
  99. (define (file-exists? f) #f)
  100.  
  101. ;;; (DELETE-FILE <string>)
  102. (define (delete-file f) #f)
  103.  
  104. ;;; FORCE-OUTPUT flushes any pending output on optional arg output port
  105. ;;; use this definition if your system doesn't have such a procedure.
  106. (define (force-output . arg)
  107.   ((access-scheme-48 'force-output)
  108.    (if (null? arg) (current-output-port) (car arg))))
  109.  
  110. ;;; CHAR-CODE-LIMIT is one greater than the largest integer which can
  111. ;;; be returned by CHAR->INTEGER.
  112. (define integer->char (access-scheme-48 'ascii->char))
  113. (define char->integer
  114.   (let ((char->integer char->integer)
  115.     (code0 (char->integer (integer->char 0))))
  116.     (lambda (char) (- (char->integer char) code0))))
  117. (define char-code-limit 256)
  118.  
  119. ;;; Workaround MODULO bug
  120. (define modulo
  121.   (let ((modulo modulo))
  122.     (lambda (n1 n2)
  123.       (let ((ans (modulo n1 n2)))
  124.     (if (= ans n2) (- ans ans) ans)))))
  125.  
  126. ;;; MOST-POSITIVE-FIXNUM is used in modular.scm
  127. (define most-positive-fixnum #x1FFFFFFF)
  128.  
  129. ;;; Return argument
  130. (define (identity x) x)
  131.  
  132. ;;; If your implementation provides eval, SLIB:EVAL is single argument
  133. ;;; eval using the top-level (user) environment.
  134. (define slib:eval
  135.   (let ((eval eval)
  136.     (interaction-environment interaction-environment))
  137.     (lambda (form)
  138.       (eval form (interaction-environment)))))
  139.  
  140. ;;; If your implementation provides R4RS macros:
  141. (define macro:eval slib:eval)
  142. (define macro:load load)
  143.  
  144. (define *defmacros*
  145.   (list (cons 'defmacro
  146.           (lambda (name parms . body)
  147.         `(set! *defmacros* (cons (cons ',name (lambda ,parms ,@body))
  148.                       *defmacros*))))))
  149. (define (defmacro? m) (and (assq m *defmacros*) #t))
  150.  
  151. (define (macroexpand-1 e)
  152.   (if (pair? e) (let ((a (car e)))
  153.           (cond ((symbol? a) (set! a (assq a *defmacros*))
  154.                      (if a (apply (cdr a) (cdr e)) e))
  155.             (else e)))
  156.       e))
  157.  
  158. (define (macroexpand e)
  159.   (if (pair? e) (let ((a (car e)))
  160.           (cond ((symbol? a)
  161.              (set! a (assq a *defmacros*))
  162.              (if a (macroexpand (apply (cdr a) (cdr e))) e))
  163.             (else e)))
  164.       e))
  165.  
  166. (define gentemp
  167.   (let ((*gensym-counter* -1))
  168.     (lambda ()
  169.       (set! *gensym-counter* (+ *gensym-counter* 1))
  170.       (string->symbol
  171.        (string-append "slib:G" (number->string *gensym-counter*))))))
  172.  
  173. (define base:eval slib:eval)
  174. (define (defmacro:eval x) (base:eval (defmacro:expand* x)))
  175. (define (defmacro:expand* x)
  176.   (require 'defmacroexpand) (apply defmacro:expand* x '()))
  177.  
  178. (define (defmacro:load <pathname>)
  179.   (slib:eval-load <pathname> defmacro:eval))
  180.  
  181. (define (slib:eval-load <pathname> evl)
  182.   (if (not (file-exists? <pathname>))
  183.       (set! <pathname> (string-append <pathname> (scheme-file-suffix))))
  184.   (call-with-input-file <pathname>
  185.     (lambda (port)
  186.       (let ((old-load-pathname *load-pathname*))
  187.     (set! *load-pathname* <pathname>)
  188.     (do ((o (read port) (read port)))
  189.         ((eof-object? o))
  190.       (evl o))
  191.     (set! *load-pathname* old-load-pathname)))))
  192.  
  193. ;;; define an error procedure for the library
  194. (define slib:error (access-scheme-48 'error))
  195.  
  196. ;;; define these as appropriate for your system.
  197. (define slib:tab (integer->char 9))
  198. (define slib:form-feed (integer->char 12))
  199.  
  200. ;;; Support for older versions of Scheme.  Not enough code for its own file.
  201. (define (last-pair l) (if (pair? (cdr l)) (last-pair (cdr l)) l))
  202. (define t #t)
  203. (define nil #f)
  204.  
  205. ;;; Define these if your implementation's syntax can support them and if
  206. ;;; they are not already defined.
  207.  
  208. (define (1+ n) (+ n 1))
  209. (define (-1+ n) (+ n -1))
  210. ;(define 1- -1+)
  211.  
  212. (define in-vicinity string-append)
  213.  
  214. ;;; Define SLIB:EXIT to be the implementation procedure to exit or
  215. ;;; return if exitting not supported.
  216. (define slib:exit (lambda args #f))
  217.  
  218. ;;; Here for backward compatability
  219. (define scheme-file-suffix
  220.   (case (software-type)
  221.     ((NOSVE) (lambda () "_scm"))
  222.     (else (lambda () ".scm"))))
  223.  
  224. ;;; (SLIB:LOAD-SOURCE "foo") should load "foo.scm" or with whatever
  225. ;;; suffix all the module files in SLIB have.  See feature 'SOURCE.
  226.  
  227. (define (slib:load-source f) (load (string-append f (scheme-file-suffix))))
  228.  
  229. ;;; (SLIB:LOAD-COMPILED "foo") should load the file that was produced
  230. ;;; by compiling "foo.scm" if this implementation can compile files.
  231. ;;; See feature 'COMPILED.
  232.  
  233. (define slib:load-compiled load)
  234.  
  235. ;;; At this point SLIB:LOAD must be able to load SLIB files.
  236.  
  237. (define slib:load slib:load-source)
  238.  
  239. (slib:load (in-vicinity (library-vicinity) "require"))
  240.